home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1993 July / InfoMagic USENET CD-ROM July 1993.ISO / sources / unix / volume6 / xlisp1.6 / part1 next >
Encoding:
Internet Message Format  |  1986-11-30  |  55.3 KB
  1. Subject:  v06i107:  Xlisp version 1.6 (xlisp1.6), Part01/06
  2. Newsgroups: mod.sources
  3. Approved: rs@mirror.UUCP
  4.  
  5. Submitted by: seismo!utah-cs!b-davis (Brad Davis)
  6. Mod.sources: Volume 6, Issue 107
  7. Archive-name: xlisp1.6/Part01
  8.  
  9. [  This unpacks, compiles, and runs a couple of the demo programs on
  10.    my 4.2BSD Vax750.  I have not tried it on a PC.  --r$  ]
  11.  
  12.  
  13. -------------------------------- Cut Here --------------------------------
  14. #! /bin/sh
  15. # This is a shell archive, meaning:
  16. # 1. Remove everything above the #! /bin/sh line.
  17. # 2. Save the resulting text in a file.
  18. # 3. Execute the file with /bin/sh (not csh) to create the files:
  19. #    xlbfun.c
  20. #    xlcont.c
  21. #    xldbug.c
  22. #    xldmem.c
  23. #    xleval.c
  24. # This archive created: Mon Jul 14 10:21:31 1986
  25. export PATH; PATH=/bin:$PATH
  26. if test -f 'xlbfun.c'
  27. then
  28.     echo shar: will not over-write existing file "'xlbfun.c'"
  29. else
  30. cat << \SHAR_EOF > 'xlbfun.c'
  31. /* xlbfun.c - xlisp basic built-in functions */
  32. /*    Copyright (c) 1985, by David Michael Betz
  33.     All Rights Reserved
  34.     Permission is granted for unrestricted non-commercial use    */
  35.  
  36. #include "xlisp.h"
  37.  
  38. /* external variables */
  39. extern NODE ***xlstack,*xlenv;
  40. extern NODE *s_car,*s_cdr,*s_nth,*s_get,*s_svalue,*s_splist,*s_aref;
  41. extern NODE *s_lambda,*s_macro;
  42. extern NODE *s_comma,*s_comat;
  43. extern NODE *s_unbound;
  44. extern char gsprefix[];
  45. extern int gsnumber;
  46.  
  47. /* forward declarations */
  48. FORWARD NODE *bquote1();
  49. FORWARD NODE *defun();
  50. FORWARD NODE *makesymbol();
  51.  
  52. /* xeval - the built-in function 'eval' */
  53. NODE *xeval(args)
  54.   NODE *args;
  55. {
  56.     NODE ***oldstk,*expr,*val;
  57.  
  58.     /* create a new stack frame */
  59.     oldstk = xlsave(&expr,(NODE **)NULL);
  60.  
  61.     /* get the expression to evaluate */
  62.     expr = xlarg(&args);
  63.     xllastarg(args);
  64.  
  65.     /* evaluate the expression */
  66.     val = xleval(expr);
  67.  
  68.     /* restore the previous stack frame */
  69.     xlstack = oldstk;
  70.  
  71.     /* return the expression evaluated */
  72.     return (val);
  73. }
  74.  
  75. /* xapply - the built-in function 'apply' */
  76. NODE *xapply(args)
  77.   NODE *args;
  78. {
  79.     NODE ***oldstk,*fun,*arglist,*val;
  80.  
  81.     /* create a new stack frame */
  82.     oldstk = xlsave(&fun,&arglist,(NODE **)NULL);
  83.  
  84.     /* get the function and argument list */
  85.     fun = xlarg(&args);
  86.     arglist = xlmatch(LIST,&args);
  87.     xllastarg(args);
  88.  
  89.     /* if the function is a symbol, get its value */
  90.     if (symbolp(fun))
  91.     fun = xleval(fun);
  92.  
  93.     /* apply the function to the arguments */
  94.     val = xlapply(fun,arglist);
  95.  
  96.     /* restore the previous stack frame */
  97.     xlstack = oldstk;
  98.  
  99.     /* return the expression evaluated */
  100.     return (val);
  101. }
  102.  
  103. /* xfuncall - the built-in function 'funcall' */
  104. NODE *xfuncall(args)
  105.   NODE *args;
  106. {
  107.     NODE ***oldstk,*fun,*arglist,*val;
  108.  
  109.     /* create a new stack frame */
  110.     oldstk = xlsave(&fun,&arglist,(NODE **)NULL);
  111.  
  112.     /* get the function and argument list */
  113.     fun = xlarg(&args);
  114.     arglist = args;
  115.  
  116.     /* if the function is a symbol, get its value */
  117.     if (symbolp(fun))
  118.     fun = xleval(fun);
  119.  
  120.     /* apply the function to the arguments */
  121.     val = xlapply(fun,arglist);
  122.  
  123.     /* restore the previous stack frame */
  124.     xlstack = oldstk;
  125.  
  126.     /* return the expression evaluated */
  127.     return (val);
  128. }
  129.  
  130. /* xquote - built-in function to quote an expression */
  131. NODE *xquote(args)
  132.   NODE *args;
  133. {
  134.     NODE *val;
  135.  
  136.     /* get the argument */
  137.     val = xlarg(&args);
  138.     xllastarg(args);
  139.  
  140.     /* return the quoted expression */
  141.     return (val);
  142. }
  143.  
  144. /* xfunction - built-in function to quote a function */
  145. NODE *xfunction(args)
  146.   NODE *args;
  147. {
  148.     NODE *val;
  149.  
  150.     /* get the argument */
  151.     val = xlarg(&args);
  152.     xllastarg(args);
  153.  
  154.     /* create a closure for lambda expressions */
  155.     if (consp(val) && car(val) == s_lambda)
  156.     val = cons(val,xlenv);
  157.  
  158.     /* otherwise, get the value of a symbol */
  159.     else if (symbolp(val))
  160.     val = xlgetvalue(val);
  161.  
  162.     /* otherwise, its an error */
  163.     else
  164.     xlerror("not a function",val);
  165.  
  166.     /* return the function */
  167.     return (val);
  168. }
  169.  
  170. /* xlambda - lambda function */
  171. NODE *xlambda(args)
  172.   NODE *args;
  173. {
  174.     NODE ***oldstk,*fargs,*closure;
  175.  
  176.     /* create a new stack frame */
  177.     oldstk = xlsave(&fargs,&closure,(NODE **)NULL);
  178.  
  179.     /* get the formal argument list */
  180.     fargs = xlmatch(LIST,&args);
  181.  
  182.     /* create a new function definition */
  183.     closure = cons(fargs,args);
  184.     closure = cons(s_lambda,closure);
  185.     closure = cons(closure,xlenv);
  186.  
  187.     /* restore the previous stack frame */
  188.     xlstack = oldstk;
  189.  
  190.     /* return the closure */
  191.     return (closure);
  192. }
  193.  
  194. /* xbquote - back quote function */
  195. NODE *xbquote(args)
  196.   NODE *args;
  197. {
  198.     NODE ***oldstk,*expr,*val;
  199.  
  200.     /* create a new stack frame */
  201.     oldstk = xlsave(&expr,(NODE **)NULL);
  202.  
  203.     /* get the expression */
  204.     expr = xlarg(&args);
  205.     xllastarg(args);
  206.  
  207.     /* fill in the template */
  208.     val = bquote1(expr);
  209.  
  210.     /* restore the previous stack frame */
  211.     xlstack = oldstk;
  212.  
  213.     /* return the result */
  214.     return (val);
  215. }
  216.  
  217. /* bquote1 - back quote helper function */
  218. LOCAL NODE *bquote1(expr)
  219.   NODE *expr;
  220. {
  221.     NODE ***oldstk,*val,*list,*last,*new;
  222.  
  223.     /* handle atoms */
  224.     if (atom(expr))
  225.     val = expr;
  226.  
  227.     /* handle (comma <expr>) */
  228.     else if (car(expr) == s_comma) {
  229.     if (atom(cdr(expr)))
  230.         xlfail("bad comma expression");
  231.     val = xleval(car(cdr(expr)));
  232.     }
  233.  
  234.     /* handle ((comma-at <expr>) ... ) */
  235.     else if (consp(car(expr)) && car(car(expr)) == s_comat) {
  236.     oldstk = xlsave(&list,&val,(NODE **)NULL);
  237.     if (atom(cdr(car(expr))))
  238.         xlfail("bad comma-at expression");
  239.     list = xleval(car(cdr(car(expr))));
  240.     for (last = NIL; consp(list); list = cdr(list)) {
  241.         new = consa(car(list));
  242.         if (last)
  243.         rplacd(last,new);
  244.         else
  245.         val = new;
  246.         last = new;
  247.     }
  248.     if (last)
  249.         rplacd(last,bquote1(cdr(expr)));
  250.     else
  251.         val = bquote1(cdr(expr));
  252.     xlstack = oldstk;
  253.     }
  254.  
  255.     /* handle any other list */
  256.     else {
  257.     oldstk = xlsave(&val,(NODE **)NULL);
  258.     val = consa(NIL);
  259.     rplaca(val,bquote1(car(expr)));
  260.     rplacd(val,bquote1(cdr(expr)));
  261.     xlstack = oldstk;
  262.     }
  263.  
  264.     /* return the result */
  265.     return (val);
  266. }
  267.  
  268. /* xset - built-in function set */
  269. NODE *xset(args)
  270.   NODE *args;
  271. {
  272.     NODE *sym,*val;
  273.  
  274.     /* get the symbol and new value */
  275.     sym = xlmatch(SYM,&args);
  276.     val = xlarg(&args);
  277.     xllastarg(args);
  278.  
  279.     /* assign the symbol the value of argument 2 and the return value */
  280.     setvalue(sym,val);
  281.  
  282.     /* return the result value */
  283.     return (val);
  284. }
  285.  
  286. /* xsetq - built-in function setq */
  287. NODE *xsetq(args)
  288.   NODE *args;
  289. {
  290.     NODE ***oldstk,*arg,*sym,*val;
  291.  
  292.     /* create a new stack frame */
  293.     oldstk = xlsave(&arg,&sym,&val,(NODE **)NULL);
  294.  
  295.     /* initialize */
  296.     arg = args;
  297.  
  298.     /* handle each pair of arguments */
  299.     while (arg) {
  300.     sym = xlmatch(SYM,&arg);
  301.     val = xlevarg(&arg);
  302.     xlsetvalue(sym,val);
  303.     }
  304.  
  305.     /* restore the previous stack frame */
  306.     xlstack = oldstk;
  307.  
  308.     /* return the result value */
  309.     return (val);
  310. }
  311.  
  312. /* xsetf - built-in function 'setf' */
  313. NODE *xsetf(args)
  314.   NODE *args;
  315. {
  316.     NODE ***oldstk,*arg,*place,*value;
  317.  
  318.     /* create a new stack frame */
  319.     oldstk = xlsave(&arg,&place,&value,(NODE **)NULL);
  320.  
  321.     /* initialize */
  322.     arg = args;
  323.  
  324.     /* handle each pair of arguments */
  325.     while (arg) {
  326.  
  327.     /* get place and value */
  328.     place = xlarg(&arg);
  329.     value = xlevarg(&arg);
  330.  
  331.     /* check the place form */
  332.     if (symbolp(place))
  333.         xlsetvalue(place,value);
  334.     else if (consp(place))
  335.         placeform(place,value);
  336.     else
  337.         xlfail("bad place form");
  338.     }
  339.  
  340.     /* restore the previous stack frame */
  341.     xlstack = oldstk;
  342.  
  343.     /* return the value */
  344.     return (value);
  345. }
  346.  
  347. /* placeform - handle a place form other than a symbol */
  348. LOCAL placeform(place,value)
  349.   NODE *place,*value;
  350. {
  351.     NODE ***oldstk,*fun,*arg1,*arg2;
  352.     int i;
  353.  
  354.     /* check the function name */
  355.     if ((fun = xlmatch(SYM,&place)) == s_get) {
  356.     oldstk = xlsave(&arg1,&arg2,(NODE **)NULL);
  357.     arg1 = xlevmatch(SYM,&place);
  358.     arg2 = xlevmatch(SYM,&place);
  359.     xllastarg(place);
  360.     xlputprop(arg1,value,arg2);
  361.     xlstack = oldstk;
  362.     }
  363.     else if (fun == s_svalue || fun == s_splist) {
  364.     oldstk = xlsave(&arg1,(NODE **)NULL);
  365.     arg1 = xlevmatch(SYM,&place);
  366.     xllastarg(place);
  367.     if (fun == s_svalue)
  368.         setvalue(arg1,value);
  369.     else
  370.         setplist(arg1,value);
  371.     xlstack = oldstk;
  372.     }
  373.     else if (fun == s_car || fun == s_cdr) {
  374.     oldstk = xlsave(&arg1,(NODE **)NULL);
  375.     arg1 = xlevmatch(LIST,&place);
  376.     xllastarg(place);
  377.     if (consp(arg1))
  378.         if (fun == s_car)
  379.         rplaca(arg1,value);
  380.         else
  381.         rplacd(arg1,value);
  382.     xlstack = oldstk;
  383.     }
  384.     else if (fun == s_nth) {
  385.     oldstk = xlsave(&arg1,&arg2,(NODE **)NULL);
  386.     arg1 = xlevmatch(INT,&place);
  387.     arg2 = xlevmatch(LIST,&place);
  388.     xllastarg(place);
  389.     for (i = (int)getfixnum(arg1); i > 0 && consp(arg2); --i)
  390.         arg2 = cdr(arg2);
  391.     if (consp(arg2))
  392.         rplaca(arg2,value);
  393.     xlstack = oldstk;
  394.     }
  395.  
  396.     else if (fun == s_aref) {
  397.     oldstk = xlsave(&arg1,&arg2,(NODE **)NULL);
  398.     arg1 = xlevmatch(VECT,&place);
  399.     arg2 = xlevmatch(INT,&place); i = (int)getfixnum(arg2);
  400.     xllastarg(place);
  401.     if (i < 0 || i >= getsize(arg1))
  402.         xlerror("index out of range",arg2);
  403.     setelement(arg1,i,value);
  404.     xlstack = oldstk;
  405.     }
  406.     else
  407.     xlfail("bad place form");
  408. }
  409.                
  410. /* xdefun - built-in function 'defun' */
  411. NODE *xdefun(args)
  412.   NODE *args;
  413. {
  414.     return (defun(args,s_lambda));
  415. }
  416.  
  417. /* xdefmacro - built-in function 'defmacro' */
  418. NODE *xdefmacro(args)
  419.   NODE *args;
  420. {
  421.     return (defun(args,s_macro));
  422. }
  423.  
  424. /* defun - internal function definition routine */
  425. LOCAL NODE *defun(args,type)
  426.   NODE *args,*type;
  427. {
  428.     NODE ***oldstk,*sym,*fargs,*closure;
  429.  
  430.     /* create a new stack frame */
  431.     oldstk = xlsave(&sym,&fargs,&closure,(NODE **)NULL);
  432.  
  433.     /* get the function symbol and formal argument list */
  434.     sym = xlmatch(SYM,&args);
  435.     fargs = xlmatch(LIST,&args);
  436.  
  437.     /* create a new function definition */
  438.     closure = cons(fargs,args);
  439.     closure = cons(type,closure);
  440.     closure = cons(closure,xlenv);
  441.  
  442.     /* make the symbol point to a new function definition */
  443.     xlsetvalue(sym,closure);
  444.  
  445.     /* restore the previous stack frame */
  446.     xlstack = oldstk;
  447.  
  448.     /* return the function symbol */
  449.     return (sym);
  450. }
  451.  
  452. /* xgensym - generate a symbol */
  453. NODE *xgensym(args)
  454.   NODE *args;
  455. {
  456.     char sym[STRMAX+1];
  457.     NODE *x;
  458.  
  459.     /* get the prefix or number */
  460.     if (args) {
  461.     x = xlarg(&args);
  462.     switch (ntype(x)) {
  463.     case STR:
  464.         strcpy(gsprefix,getstring(x));
  465.         break;
  466.     case INT:
  467.         gsnumber = getfixnum(x);
  468.         break;
  469.     default:
  470.         xlerror("bad argument type",x);
  471.     }
  472.     }
  473.     xllastarg(args);
  474.  
  475.     /* create the pname of the new symbol */
  476.     sprintf(sym,"%s%d",gsprefix,gsnumber++);
  477.  
  478.     /* make a symbol with this print name */
  479.     return (xlmakesym(sym,DYNAMIC));
  480. }
  481.  
  482. /* xmakesymbol - make a new uninterned symbol */
  483. NODE *xmakesymbol(args)
  484.   NODE *args;
  485. {
  486.     return (makesymbol(args,FALSE));
  487. }
  488.  
  489. /* xintern - make a new interned symbol */
  490. NODE *xintern(args)
  491.   NODE *args;
  492. {
  493.     return (makesymbol(args,TRUE));
  494. }
  495.  
  496. /* makesymbol - make a new symbol */
  497. LOCAL NODE *makesymbol(args,iflag)
  498.   NODE *args; int iflag;
  499. {
  500.     NODE ***oldstk,*pname,*val;
  501.     char *str;
  502.  
  503.     /* create a new stack frame */
  504.     oldstk = xlsave(&pname,(NODE **)NULL);
  505.  
  506.     /* get the print name of the symbol to intern */
  507.     pname = xlmatch(STR,&args);
  508.     xllastarg(args);
  509.  
  510.     /* make the symbol */
  511.     str = getstring(pname);
  512.     val = (iflag ? xlenter(str,DYNAMIC) : xlmakesym(str,DYNAMIC));
  513.  
  514.     /* restore the previous stack frame */
  515.     xlstack = oldstk;
  516.  
  517.     /* return the symbol */
  518.     return (val);
  519. }
  520.  
  521. /* xsymname - get the print name of a symbol */
  522. NODE *xsymname(args)
  523.   NODE *args;
  524. {
  525.     NODE *sym;
  526.  
  527.     /* get the symbol */
  528.     sym = xlmatch(SYM,&args);
  529.     xllastarg(args);
  530.  
  531.     /* return the print name */
  532.     return (getpname(sym));
  533. }
  534.  
  535. /* xsymvalue - get the value of a symbol */
  536. NODE *xsymvalue(args)
  537.   NODE *args;
  538. {
  539.     NODE *sym,*val;
  540.  
  541.     /* get the symbol */
  542.     sym = xlmatch(SYM,&args);
  543.     xllastarg(args);
  544.  
  545.     /* get the global value */
  546.     while ((val = getvalue(sym)) == s_unbound)
  547.     xlcerror("try evaluating symbol again","unbound variable",sym);
  548.  
  549.     /* return its value */
  550.     return (val);
  551. }
  552.  
  553. /* xsymplist - get the property list of a symbol */
  554. NODE *xsymplist(args)
  555.   NODE *args;
  556. {
  557.     NODE *sym;
  558.  
  559.     /* get the symbol */
  560.     sym = xlmatch(SYM,&args);
  561.     xllastarg(args);
  562.  
  563.     /* return the property list */
  564.     return (getplist(sym));
  565. }
  566.  
  567. /* xget - get the value of a property */
  568. NODE *xget(args)
  569.   NODE *args;
  570. {
  571.     NODE *sym,*prp;
  572.  
  573.     /* get the symbol and property */
  574.     sym = xlmatch(SYM,&args);
  575.     prp = xlmatch(SYM,&args);
  576.     xllastarg(args);
  577.  
  578.     /* retrieve the property value */
  579.     return (xlgetprop(sym,prp));
  580. }
  581.  
  582. /* xputprop - set the value of a property */
  583. NODE *xputprop(args)
  584.   NODE *args;
  585. {
  586.     NODE *sym,*val,*prp;
  587.  
  588.     /* get the symbol and property */
  589.     sym = xlmatch(SYM,&args);
  590.     val = xlarg(&args);
  591.     prp = xlmatch(SYM,&args);
  592.     xllastarg(args);
  593.  
  594.     /* set the property value */
  595.     xlputprop(sym,val,prp);
  596.  
  597.     /* return the value */
  598.     return (val);
  599. }
  600.  
  601. /* xremprop - remove a property value from a property list */
  602. NODE *xremprop(args)
  603.   NODE *args;
  604. {
  605.     NODE *sym,*prp;
  606.  
  607.     /* get the symbol and property */
  608.     sym = xlmatch(SYM,&args);
  609.     prp = xlmatch(SYM,&args);
  610.     xllastarg(args);
  611.  
  612.     /* remove the property */
  613.     xlremprop(sym,prp);
  614.  
  615.     /* return nil */
  616.     return (NIL);
  617. }
  618.  
  619. /* xhash - compute the hash value of a string or symbol */
  620. NODE *xhash(args)
  621.   NODE *args;
  622. {
  623.     char *str;
  624.     NODE *val;
  625.     int len;
  626.  
  627.     /* get the string and the table length */
  628.     val = xlarg(&args);
  629.     len = (int)getfixnum(xlmatch(INT,&args));
  630.     xllastarg(args);
  631.  
  632.     /* get the string */
  633.     if (symbolp(val))
  634.     str = getstring(getpname(val));
  635.     else if (stringp(val))
  636.     str = getstring(val);
  637.     else
  638.     xlerror("bad argument type",val);
  639.  
  640.     /* return the hash index */
  641.     return (cvfixnum((FIXNUM)hash(str,len)));
  642. }
  643.  
  644. /* xaref - array reference function */
  645. NODE *xaref(args)
  646.   NODE *args;
  647. {
  648.     NODE *array,*index;
  649.     int i;
  650.  
  651.     /* get the array and the index */
  652.     array = xlmatch(VECT,&args);
  653.     index = xlmatch(INT,&args); i = (int)getfixnum(index);
  654.     xllastarg(args);
  655.  
  656.     /* range check the index */
  657.     if (i < 0 || i >= getsize(array))
  658.     xlerror("array index out of bounds",index);
  659.  
  660.     /* return the array element */
  661.     return (getelement(array,i));
  662. }
  663.  
  664. /* xmkarray - make a new array */
  665. NODE *xmkarray(args)
  666.   NODE *args;
  667. {
  668.     int size;
  669.  
  670.     /* get the size of the array */
  671.     size = (int)getfixnum(xlmatch(INT,&args));
  672.     xllastarg(args);
  673.  
  674.     /* create the array */
  675.     return (newvector(size));
  676. }
  677.  
  678. SHAR_EOF
  679. fi # end of overwriting check
  680. if test -f 'xlcont.c'
  681. then
  682.     echo shar: will not over-write existing file "'xlcont.c'"
  683. else
  684. cat << \SHAR_EOF > 'xlcont.c'
  685. /* xlcont - xlisp control built-in functions */
  686. /*    Copyright (c) 1985, by David Michael Betz
  687.     All Rights Reserved
  688.     Permission is granted for unrestricted non-commercial use    */
  689.  
  690. #include "xlisp.h"
  691.  
  692. /* external variables */
  693. extern NODE ***xlstack,*xlenv,*xlvalue;
  694. extern NODE *s_unbound;
  695. extern NODE *s_evalhook,*s_applyhook;
  696. extern NODE *true;
  697.  
  698. /* external routines */
  699. extern NODE *xlxeval();
  700.  
  701. /* forward declarations */
  702. FORWARD NODE *let();
  703. FORWARD NODE *prog();
  704. FORWARD NODE *progx();
  705. FORWARD NODE *doloop();
  706.  
  707. /* xcond - built-in function 'cond' */
  708. NODE *xcond(args)
  709.   NODE *args;
  710. {
  711.     NODE ***oldstk,*arg,*list,*val;
  712.  
  713.     /* create a new stack frame */
  714.     oldstk = xlsave(&arg,&list,(NODE **)NULL);
  715.  
  716.     /* initialize */
  717.     arg = args;
  718.  
  719.     /* initialize the return value */
  720.     val = NIL;
  721.  
  722.     /* find a predicate that is true */
  723.     while (arg) {
  724.  
  725.     /* get the next conditional */
  726.     list = xlmatch(LIST,&arg);
  727.  
  728.     /* evaluate the predicate part */
  729.     if (val = xlevarg(&list)) {
  730.  
  731.         /* evaluate each expression */
  732.         while (list)
  733.         val = xlevarg(&list);
  734.  
  735.         /* exit the loop */
  736.         break;
  737.     }
  738.     }
  739.  
  740.     /* restore the previous stack frame */
  741.     xlstack = oldstk;
  742.  
  743.     /* return the value */
  744.     return (val);
  745. }
  746.  
  747. /* xcase - built-in function 'case' */
  748. NODE *xcase(args)
  749.   NODE *args;
  750. {
  751.     NODE ***oldstk,*key,*arg,*clause,*list,*val;
  752.  
  753.     /* create a new stack frame */
  754.     oldstk = xlsave(&key,&arg,&clause,(NODE **)NULL);
  755.  
  756.     /* initialize */
  757.     arg = args;
  758.  
  759.     /* get the key expression */
  760.     key = xlevarg(&arg);
  761.  
  762.     /* initialize the return value */
  763.     val = NIL;
  764.  
  765.     /* find a case that matches */
  766.     while (arg) {
  767.  
  768.     /* get the next case clause */
  769.     clause = xlmatch(LIST,&arg);
  770.  
  771.     /* compare the key list against the key */
  772.     if ((list = xlarg(&clause)) == true ||
  773.             (listp(list) && keypresent(key,list)) ||
  774.             eql(key,list)) {
  775.  
  776.         /* evaluate each expression */
  777.         while (clause)
  778.         val = xlevarg(&clause);
  779.  
  780.         /* exit the loop */
  781.         break;
  782.     }
  783.     }
  784.  
  785.     /* restore the previous stack frame */
  786.     xlstack = oldstk;
  787.  
  788.     /* return the value */
  789.     return (val);
  790. }
  791.  
  792. /* keypresent - check for the presence of a key in a list */
  793. LOCAL int keypresent(key,list)
  794.   NODE *key,*list;
  795. {
  796.     for (; consp(list); list = cdr(list))
  797.     if (eql(car(list),key))
  798.         return (TRUE);
  799.     return (FALSE);
  800. }
  801.  
  802. /* xand - built-in function 'and' */
  803. NODE *xand(args)
  804.   NODE *args;
  805. {
  806.     NODE ***oldstk,*arg,*val;
  807.  
  808.     /* create a new stack frame */
  809.     oldstk = xlsave(&arg,(NODE **)NULL);
  810.  
  811.     /* initialize */
  812.     arg = args;
  813.     val = true;
  814.  
  815.     /* evaluate each argument */
  816.     while (arg)
  817.  
  818.     /* get the next argument */
  819.     if ((val = xlevarg(&arg)) == NIL)
  820.         break;
  821.  
  822.     /* restore the previous stack frame */
  823.     xlstack = oldstk;
  824.  
  825.     /* return the result value */
  826.     return (val);
  827. }
  828.  
  829. /* xor - built-in function 'or' */
  830. NODE *xor(args)
  831.   NODE *args;
  832. {
  833.     NODE ***oldstk,*arg,*val;
  834.  
  835.     /* create a new stack frame */
  836.     oldstk = xlsave(&arg,(NODE **)NULL);
  837.  
  838.     /* initialize */
  839.     arg = args;
  840.     val = NIL;
  841.  
  842.     /* evaluate each argument */
  843.     while (arg)
  844.     if ((val = xlevarg(&arg)))
  845.         break;
  846.  
  847.     /* restore the previous stack frame */
  848.     xlstack = oldstk;
  849.  
  850.     /* return the result value */
  851.     return (val);
  852. }
  853.  
  854. /* xif - built-in function 'if' */
  855. NODE *xif(args)
  856.   NODE *args;
  857. {
  858.     NODE ***oldstk,*testexpr,*thenexpr,*elseexpr,*val;
  859.  
  860.     /* create a new stack frame */
  861.     oldstk = xlsave(&testexpr,&thenexpr,&elseexpr,(NODE **)NULL);
  862.  
  863.     /* get the test expression, then clause and else clause */
  864.     testexpr = xlarg(&args);
  865.     thenexpr = xlarg(&args);
  866.     elseexpr = (args ? xlarg(&args) : NIL);
  867.     xllastarg(args);
  868.  
  869.     /* evaluate the appropriate clause */
  870.     val = xleval(xleval(testexpr) ? thenexpr : elseexpr);
  871.  
  872.     /* restore the previous stack frame */
  873.     xlstack = oldstk;
  874.  
  875.     /* return the last value */
  876.     return (val);
  877. }
  878.  
  879. /* xlet - built-in function 'let' */
  880. NODE *xlet(args)
  881.   NODE *args;
  882. {
  883.     return (let(args,TRUE));
  884. }
  885.  
  886. /* xletstar - built-in function 'let*' */
  887. NODE *xletstar(args)
  888.   NODE *args;
  889. {
  890.     return (let(args,FALSE));
  891. }
  892.  
  893. /* let - common let routine */
  894. LOCAL NODE *let(args,pflag)
  895.   NODE *args; int pflag;
  896. {
  897.     NODE ***oldstk,*newenv,*arg,*val;
  898.  
  899.     /* create a new stack frame */
  900.     oldstk = xlsave(&newenv,&arg,(NODE **)NULL);
  901.  
  902.     /* initialize */
  903.     arg = args;
  904.  
  905.     /* create a new environment frame */
  906.     newenv = xlframe(xlenv);
  907.  
  908.     /* get the list of bindings and bind the symbols */
  909.     if (!pflag) xlenv = newenv;
  910.     dobindings(xlmatch(LIST,&arg),newenv);
  911.     if (pflag) xlenv = newenv;
  912.  
  913.     /* execute the code */
  914.     for (val = NIL; arg; )
  915.     val = xlevarg(&arg);
  916.  
  917.     /* unbind the arguments */
  918.     xlenv = cdr(xlenv);
  919.  
  920.     /* restore the previous stack frame */
  921.     xlstack = oldstk;
  922.  
  923.     /* return the result */
  924.     return (val);
  925. }
  926.  
  927. /* xprog - built-in function 'prog' */
  928. NODE *xprog(args)
  929.   NODE *args;
  930. {
  931.     return (prog(args,TRUE));
  932. }
  933.  
  934. /* xprogstar - built-in function 'prog*' */
  935. NODE *xprogstar(args)
  936.   NODE *args;
  937. {
  938.     return (prog(args,FALSE));
  939. }
  940.  
  941. /* prog - common prog routine */
  942. LOCAL NODE *prog(args,pflag)
  943.   NODE *args; int pflag;
  944. {
  945.     NODE ***oldstk,*newenv,*arg,*val;
  946.  
  947.     /* create a new stack frame */
  948.     oldstk = xlsave(&newenv,&arg,(NODE **)NULL);
  949.  
  950.     /* initialize */
  951.     arg = args;
  952.  
  953.     /* create a new environment frame */
  954.     newenv = xlframe(xlenv);
  955.  
  956.     /* get the list of bindings and bind the symbols */
  957.     if (!pflag) xlenv = newenv;
  958.     dobindings(xlmatch(LIST,&arg),newenv);
  959.     if (pflag) xlenv = newenv;
  960.  
  961.     /* execute the code */
  962.     tagblock(arg,&val);
  963.  
  964.     /* unbind the arguments */
  965.     xlenv = cdr(xlenv);
  966.  
  967.     /* restore the previous stack frame */
  968.     xlstack = oldstk;
  969.  
  970.     /* return the result */
  971.     return (val);
  972. }
  973.  
  974. /* xgo - built-in function 'go' */
  975. NODE *xgo(args)
  976.   NODE *args;
  977. {
  978.     NODE *label;
  979.  
  980.     /* get the target label */
  981.     label = xlarg(&args);
  982.     xllastarg(args);
  983.  
  984.     /* transfer to the label */
  985.     xlgo(label);
  986. }
  987.  
  988. /* xreturn - built-in function 'return' */
  989. NODE *xreturn(args)
  990.   NODE *args;
  991. {
  992.     NODE *val;
  993.  
  994.     /* get the return value */
  995.     val = (args ? xlarg(&args) : NIL);
  996.     xllastarg(args);
  997.  
  998.     /* return from the inner most block */
  999.     xlreturn(val);
  1000. }
  1001.  
  1002. /* xprog1 - built-in function 'prog1' */
  1003. NODE *xprog1(args)
  1004.   NODE *args;
  1005. {
  1006.     return (progx(args,1));
  1007. }
  1008.  
  1009. /* xprog2 - built-in function 'prog2' */
  1010. NODE *xprog2(args)
  1011.   NODE *args;
  1012. {
  1013.     return (progx(args,2));
  1014. }
  1015.  
  1016. /* progx - common progx code */
  1017. LOCAL NODE *progx(args,n)
  1018.   NODE *args; int n;
  1019. {
  1020.     NODE ***oldstk,*arg,*val;
  1021.  
  1022.     /* create a new stack frame */
  1023.     oldstk = xlsave(&arg,&val,(NODE **)NULL);
  1024.  
  1025.     /* initialize */
  1026.     arg = args;
  1027.  
  1028.     /* evaluate the first n expressions */
  1029.     while (n--)
  1030.     val = xlevarg(&arg);
  1031.  
  1032.     /* evaluate each remaining argument */
  1033.     while (arg)
  1034.     xlevarg(&arg);
  1035.  
  1036.     /* restore the previous stack frame */
  1037.     xlstack = oldstk;
  1038.  
  1039.     /* return the last test expression value */
  1040.     return (val);
  1041. }
  1042.  
  1043. /* xprogn - built-in function 'progn' */
  1044. NODE *xprogn(args)
  1045.   NODE *args;
  1046. {
  1047.     NODE ***oldstk,*arg,*val;
  1048.  
  1049.     /* create a new stack frame */
  1050.     oldstk = xlsave(&arg,(NODE **)NULL);
  1051.  
  1052.     /* initialize */
  1053.     arg = args;
  1054.  
  1055.     /* evaluate each remaining argument */
  1056.     for (val = NIL; arg; )
  1057.     val = xlevarg(&arg);
  1058.  
  1059.     /* restore the previous stack frame */
  1060.     xlstack = oldstk;
  1061.  
  1062.     /* return the last test expression value */
  1063.     return (val);
  1064. }
  1065.  
  1066. /* xdo - built-in function 'do' */
  1067. NODE *xdo(args)
  1068.   NODE *args;
  1069. {
  1070.     return (doloop(args,TRUE));
  1071. }
  1072.  
  1073. /* xdostar - built-in function 'do*' */
  1074. NODE *xdostar(args)
  1075.   NODE *args;
  1076. {
  1077.     return (doloop(args,FALSE));
  1078. }
  1079.  
  1080. /* doloop - common do routine */
  1081. LOCAL NODE *doloop(args,pflag)
  1082.   NODE *args; int pflag;
  1083. {
  1084.     NODE ***oldstk,*newenv,*arg,*blist,*clist,*test,*rval;
  1085.     int rbreak;
  1086.  
  1087.     /* create a new stack frame */
  1088.     oldstk = xlsave(&newenv,&arg,&blist,&clist,&test,(NODE **)NULL);
  1089.  
  1090.     /* initialize */
  1091.     arg = args;
  1092.  
  1093.     /* get the list of bindings */
  1094.     blist = xlmatch(LIST,&arg);
  1095.  
  1096.     /* create a new environment frame */
  1097.     newenv = xlframe(xlenv);
  1098.  
  1099.     /* bind the symbols */
  1100.     if (!pflag) xlenv = newenv;
  1101.     dobindings(blist,newenv);
  1102.     if (pflag) xlenv = newenv;
  1103.  
  1104.     /* get the exit test and result forms */
  1105.     clist = xlmatch(LIST,&arg);
  1106.     test = xlarg(&clist);
  1107.  
  1108.     /* execute the loop as long as the test is false */
  1109.     rbreak = FALSE;
  1110.     while (xleval(test) == NIL) {
  1111.  
  1112.     /* execute the body of the loop */
  1113.     if (tagblock(arg,&rval)) {
  1114.         rbreak = TRUE;
  1115.         break;
  1116.     }
  1117.  
  1118.     /* update the looping variables */
  1119.     doupdates(blist,pflag);
  1120.     }
  1121.  
  1122.     /* evaluate the result expression */
  1123.     if (!rbreak)
  1124.     for (rval = NIL; consp(clist); )
  1125.         rval = xlevarg(&clist);
  1126.  
  1127.     /* unbind the arguments */
  1128.     xlenv = cdr(xlenv);
  1129.  
  1130.     /* restore the previous stack frame */
  1131.     xlstack = oldstk;
  1132.  
  1133.     /* return the result */
  1134.     return (rval);
  1135. }
  1136.  
  1137. /* xdolist - built-in function 'dolist' */
  1138. NODE *xdolist(args)
  1139.   NODE *args;
  1140. {
  1141.     NODE ***oldstk,*arg,*clist,*sym,*list,*val,*rval;
  1142.     int rbreak;
  1143.  
  1144.     /* create a new stack frame */
  1145.     oldstk = xlsave(&arg,&clist,&sym,&list,&val,(NODE **)NULL);
  1146.  
  1147.     /* initialize */
  1148.     arg = args;
  1149.  
  1150.     /* get the control list (sym list result-expr) */
  1151.     clist = xlmatch(LIST,&arg);
  1152.     sym = xlmatch(SYM,&clist);
  1153.     list = xlevmatch(LIST,&clist);
  1154.     val = (clist ? xlarg(&clist) : NIL);
  1155.  
  1156.     /* initialize the local environment */
  1157.     xlenv = xlframe(xlenv);
  1158.     xlbind(sym,NIL,xlenv);
  1159.  
  1160.     /* loop through the list */
  1161.     rbreak = FALSE;
  1162.     for (; consp(list); list = cdr(list)) {
  1163.  
  1164.     /* bind the symbol to the next list element */
  1165.     xlsetvalue(sym,car(list));
  1166.  
  1167.     /* execute the loop body */
  1168.     if (tagblock(arg,&rval)) {
  1169.         rbreak = TRUE;
  1170.         break;
  1171.     }
  1172.     }
  1173.  
  1174.     /* evaluate the result expression */
  1175.     if (!rbreak) {
  1176.     xlsetvalue(sym,NIL);
  1177.     rval = xleval(val);
  1178.     }
  1179.  
  1180.     /* unbind the arguments */
  1181.     xlenv = cdr(xlenv);
  1182.  
  1183.     /* restore the previous stack frame */
  1184.     xlstack = oldstk;
  1185.  
  1186.     /* return the result */
  1187.     return (rval);
  1188. }
  1189.  
  1190. /* xdotimes - built-in function 'dotimes' */
  1191. NODE *xdotimes(args)
  1192.   NODE *args;
  1193. {
  1194.     NODE ***oldstk,*arg,*clist,*sym,*val,*rval;
  1195.     int rbreak,cnt,i;
  1196.  
  1197.     /* create a new stack frame */
  1198.     oldstk = xlsave(&arg,&clist,&sym,&val,(NODE **)NULL);
  1199.  
  1200.     /* initialize */
  1201.     arg = args;
  1202.  
  1203.     /* get the control list (sym list result-expr) */
  1204.     clist = xlmatch(LIST,&arg);
  1205.     sym = xlmatch(SYM,&clist);
  1206.     cnt = getfixnum(xlevmatch(INT,&clist));
  1207.     val = (clist ? xlarg(&clist) : NIL);
  1208.  
  1209.     /* initialize the local environment */
  1210.     xlenv = xlframe(xlenv);
  1211.     xlbind(sym,NIL,xlenv);
  1212.  
  1213.     /* loop through for each value from zero to cnt-1 */
  1214.     rbreak = FALSE;
  1215.     for (i = 0; i < cnt; i++) {
  1216.  
  1217.     /* bind the symbol to the next list element */
  1218.     xlsetvalue(sym,cvfixnum((FIXNUM)i));
  1219.  
  1220.     /* execute the loop body */
  1221.     if (tagblock(arg,&rval)) {
  1222.         rbreak = TRUE;
  1223.         break;
  1224.     }
  1225.     }
  1226.  
  1227.     /* evaluate the result expression */
  1228.     if (!rbreak) {
  1229.     xlsetvalue(sym,cvfixnum((FIXNUM)cnt));
  1230.     rval = xleval(val);
  1231.     }
  1232.  
  1233.     /* unbind the arguments */
  1234.     xlenv = cdr(xlenv);
  1235.  
  1236.     /* restore the previous stack frame */
  1237.     xlstack = oldstk;
  1238.  
  1239.     /* return the result */
  1240.     return (rval);
  1241. }
  1242.  
  1243. /* xcatch - built-in function 'catch' */
  1244. NODE *xcatch(args)
  1245.   NODE *args;
  1246. {
  1247.     NODE ***oldstk,*tag,*arg,*val;
  1248.     CONTEXT cntxt;
  1249.  
  1250.     /* create a new stack frame */
  1251.     oldstk = xlsave(&tag,&arg,(NODE **)NULL);
  1252.  
  1253.     /* initialize */
  1254.     tag = xlevarg(&args);
  1255.     arg = args;
  1256.     val = NIL;
  1257.  
  1258.     /* establish an execution context */
  1259.     xlbegin(&cntxt,CF_THROW,tag);
  1260.  
  1261.     /* check for 'throw' */
  1262.     if (setjmp(cntxt.c_jmpbuf))
  1263.     val = xlvalue;
  1264.  
  1265.     /* otherwise, evaluate the remainder of the arguments */
  1266.     else {
  1267.     while (arg)
  1268.         val = xlevarg(&arg);
  1269.     }
  1270.     xlend(&cntxt);
  1271.  
  1272.     /* restore the previous stack frame */
  1273.     xlstack = oldstk;
  1274.  
  1275.     /* return the result */
  1276.     return (val);
  1277. }
  1278.  
  1279. /* xthrow - built-in function 'throw' */
  1280. NODE *xthrow(args)
  1281.   NODE *args;
  1282. {
  1283.     NODE *tag,*val;
  1284.  
  1285.     /* get the tag and value */
  1286.     tag = xlarg(&args);
  1287.     val = (args ? xlarg(&args) : NIL);
  1288.     xllastarg(args);
  1289.  
  1290.     /* throw the tag */
  1291.     xlthrow(tag,val);
  1292. }
  1293.  
  1294. /* xerror - built-in function 'error' */
  1295. NODE *xerror(args)
  1296.   NODE *args;
  1297. {
  1298.     char *emsg; NODE *arg;
  1299.  
  1300.     /* get the error message and the argument */
  1301.     emsg = getstring(xlmatch(STR,&args));
  1302.     arg = (args ? xlarg(&args) : s_unbound);
  1303.     xllastarg(args);
  1304.  
  1305.     /* signal the error */
  1306.     xlerror(emsg,arg);
  1307. }
  1308.  
  1309. /* xcerror - built-in function 'cerror' */
  1310. NODE *xcerror(args)
  1311.   NODE *args;
  1312. {
  1313.     char *cmsg,*emsg; NODE *arg;
  1314.  
  1315.     /* get the correction message, the error message, and the argument */
  1316.     cmsg = getstring(xlmatch(STR,&args));
  1317.     emsg = getstring(xlmatch(STR,&args));
  1318.     arg = (args ? xlarg(&args) : s_unbound);
  1319.     xllastarg(args);
  1320.  
  1321.     /* signal the error */
  1322.     xlcerror(cmsg,emsg,arg);
  1323.  
  1324.     /* return nil */
  1325.     return (NIL);
  1326. }
  1327.  
  1328. /* xbreak - built-in function 'break' */
  1329. NODE *xbreak(args)
  1330.   NODE *args;
  1331. {
  1332.     char *emsg; NODE *arg;
  1333.  
  1334.     /* get the error message */
  1335.     emsg = (args ? getstring(xlmatch(STR,&args)) : "**BREAK**");
  1336.     arg = (args ? xlarg(&args) : s_unbound);
  1337.     xllastarg(args);
  1338.  
  1339.     /* enter the break loop */
  1340.     xlbreak(emsg,arg);
  1341.  
  1342.     /* return nil */
  1343.     return (NIL);
  1344. }
  1345.  
  1346. /* xcleanup - built-in function 'clean-up' */
  1347. NODE *xcleanup(args)
  1348.   NODE *args;
  1349. {
  1350.     xllastarg(args);
  1351.     xlcleanup();
  1352. }
  1353.  
  1354. /* xcontinue - built-in function 'continue' */
  1355. NODE *xcontinue(args)
  1356.   NODE *args;
  1357. {
  1358.     xllastarg(args);
  1359.     xlcontinue();
  1360. }
  1361.  
  1362. /* xerrset - built-in function 'errset' */
  1363. NODE *xerrset(args)
  1364.   NODE *args;
  1365. {
  1366.     NODE ***oldstk,*expr,*flag,*val;
  1367.     CONTEXT cntxt;
  1368.  
  1369.     /* create a new stack frame */
  1370.     oldstk = xlsave(&expr,&flag,(NODE **)NULL);
  1371.  
  1372.     /* get the expression and the print flag */
  1373.     expr = xlarg(&args);
  1374.     flag = (args ? xlarg(&args) : true);
  1375.     xllastarg(args);
  1376.  
  1377.     /* establish an execution context */
  1378.     xlbegin(&cntxt,CF_ERROR,flag);
  1379.  
  1380.     /* check for error */
  1381.     if (setjmp(cntxt.c_jmpbuf))
  1382.     val = NIL;
  1383.  
  1384.     /* otherwise, evaluate the expression */
  1385.     else {
  1386.     expr = xleval(expr);
  1387.     val = consa(expr);
  1388.     }
  1389.     xlend(&cntxt);
  1390.  
  1391.     /* restore the previous stack frame */
  1392.     xlstack = oldstk;
  1393.  
  1394.     /* return the result */
  1395.     return (val);
  1396. }
  1397.  
  1398. /* xevalhook - eval hook function */
  1399. NODE *xevalhook(args)
  1400.   NODE *args;
  1401. {
  1402.     NODE ***oldstk,*expr,*ehook,*ahook,*env,*newehook,*newahook,*newenv,*val;
  1403.  
  1404.     /* create a new stack frame */
  1405.     oldstk = xlsave(&expr,&ehook,&ahook,&env,&newehook,&newahook,&newenv,(NODE **)NULL);
  1406.  
  1407.     /* get the expression, the new hook functions and the environment */
  1408.     expr = xlarg(&args);
  1409.     newehook = xlarg(&args);
  1410.     newahook = xlarg(&args);
  1411.     newenv = (args ? xlarg(&args) : xlenv);
  1412.     xllastarg(args);
  1413.  
  1414.     /* bind *evalhook* and *applyhook* to the hook functions */
  1415.     ehook = getvalue(s_evalhook);
  1416.     setvalue(s_evalhook,newehook);
  1417.     ahook = getvalue(s_applyhook);
  1418.     setvalue(s_applyhook,newahook);
  1419.     env = xlenv;
  1420.     xlenv = newenv;
  1421.  
  1422.     /* evaluate the expression (bypassing *evalhook*) */
  1423.     val = xlxeval(expr);
  1424.  
  1425.     /* unbind the hook variables */
  1426.     setvalue(s_evalhook,ehook);
  1427.     setvalue(s_applyhook,ahook);
  1428.     xlenv = env;
  1429.  
  1430.     /* restore the previous stack frame */
  1431.     xlstack = oldstk;
  1432.  
  1433.     /* return the result */
  1434.     return (val);
  1435. }
  1436.  
  1437. /* dobindings - handle bindings for let/let*, prog/prog*, do/do* */
  1438. LOCAL dobindings(blist,env)
  1439.   NODE *blist,*env;
  1440. {
  1441.     NODE ***oldstk,*list,*bnd,*sym,*val;
  1442.  
  1443.     /* create a new stack frame */
  1444.     oldstk = xlsave(&list,&bnd,&sym,&val,(NODE **)NULL);
  1445.  
  1446.     /* bind each symbol in the list of bindings */
  1447.     for (list = blist; consp(list); list = cdr(list)) {
  1448.  
  1449.     /* get the next binding */
  1450.     bnd = car(list);
  1451.  
  1452.     /* handle a symbol */
  1453.     if (symbolp(bnd)) {
  1454.         sym = bnd;
  1455.         val = NIL;
  1456.     }
  1457.  
  1458.     /* handle a list of the form (symbol expr) */
  1459.     else if (consp(bnd)) {
  1460.         sym = xlmatch(SYM,&bnd);
  1461.         val = xlevarg(&bnd);
  1462.     }
  1463.     else
  1464.         xlfail("bad binding");
  1465.  
  1466.     /* bind the value to the symbol */
  1467.     xlbind(sym,val,env);
  1468.     }
  1469.  
  1470.     /* restore the previous stack frame */
  1471.     xlstack = oldstk;
  1472. }
  1473.  
  1474. /* doupdates - handle updates for do/do* */
  1475. doupdates(blist,pflag)
  1476.   NODE *blist; int pflag;
  1477. {
  1478.     NODE ***oldstk,*plist,*list,*bnd,*sym,*val;
  1479.  
  1480.     /* create a new stack frame */
  1481.     oldstk = xlsave(&plist,&list,&bnd,&sym,&val,(NODE **)NULL);
  1482.  
  1483.     /* bind each symbol in the list of bindings */
  1484.     for (list = blist; consp(list); list = cdr(list)) {
  1485.  
  1486.     /* get the next binding */
  1487.     bnd = car(list);
  1488.  
  1489.     /* handle a list of the form (symbol expr) */
  1490.     if (consp(bnd)) {
  1491.         sym = xlmatch(SYM,&bnd);
  1492.         bnd = cdr(bnd);
  1493.         if (bnd) {
  1494.         val = xlevarg(&bnd);
  1495.         if (pflag) {
  1496.             plist = consd(plist);
  1497.             rplaca(plist,cons(sym,val));
  1498.         }
  1499.         else
  1500.             xlsetvalue(sym,val);
  1501.         }
  1502.     }
  1503.     }
  1504.  
  1505.     /* set the values for parallel updates */
  1506.     for (; plist; plist = cdr(plist))
  1507.     xlsetvalue(car(car(plist)),cdr(car(plist)));
  1508.  
  1509.     /* restore the previous stack frame */
  1510.     xlstack = oldstk;
  1511. }
  1512.  
  1513. /* tagblock - execute code within a block and tagbody */
  1514. int tagblock(code,pval)
  1515.   NODE *code,**pval;
  1516. {
  1517.     NODE ***oldstk,*arg;
  1518.     CONTEXT cntxt;
  1519.     int type,sts;
  1520.  
  1521.     /* create a new stack frame */
  1522.     oldstk = xlsave(&arg,(NODE **)NULL);
  1523.  
  1524.     /* initialize */
  1525.     arg = code;
  1526.  
  1527.     /* establish an execution context */
  1528.     xlbegin(&cntxt,CF_GO|CF_RETURN,arg);
  1529.  
  1530.     /* check for a 'return' */
  1531.     if ((type = setjmp(cntxt.c_jmpbuf)) == CF_RETURN) {
  1532.     *pval = xlvalue;
  1533.     sts = TRUE;
  1534.     }
  1535.  
  1536.     /* otherwise, enter the body */
  1537.     else {
  1538.  
  1539.     /* check for a 'go' */
  1540.     if (type == CF_GO)
  1541.         arg = xlvalue;
  1542.  
  1543.     /* evaluate each expression in the body */
  1544.     while (consp(arg))
  1545.         if (consp(car(arg)))
  1546.         xlevarg(&arg);
  1547.         else
  1548.         arg = cdr(arg);
  1549.  
  1550.     /* fell out the bottom of the loop */
  1551.     *pval = NIL;
  1552.     sts = FALSE;
  1553.     }
  1554.     xlend(&cntxt);
  1555.  
  1556.     /* restore the previous stack frame */
  1557.     xlstack = oldstk;
  1558.  
  1559.     /* return status */
  1560.     return (sts);
  1561. }
  1562.  
  1563. SHAR_EOF
  1564. fi # end of overwriting check
  1565. if test -f 'xldbug.c'
  1566. then
  1567.     echo shar: will not over-write existing file "'xldbug.c'"
  1568. else
  1569. cat << \SHAR_EOF > 'xldbug.c'
  1570. /* xldebug - xlisp debugging support */
  1571. /*    Copyright (c) 1985, by David Michael Betz
  1572.     All Rights Reserved
  1573.     Permission is granted for unrestricted non-commercial use    */
  1574.  
  1575. #include "xlisp.h"
  1576.  
  1577. /* external variables */
  1578. extern long total;
  1579. extern int xldebug;
  1580. extern int xltrace;
  1581. extern int xlsample;
  1582. extern NODE *s_unbound;
  1583. extern NODE *s_stdin,*s_stdout;
  1584. extern NODE *s_tracenable,*s_tlimit,*s_breakenable;
  1585. extern NODE ***xlstack;
  1586. extern NODE *true;
  1587. extern NODE **trace_stack;
  1588. extern char buf[];
  1589.  
  1590. /* external routines */
  1591. extern char *malloc();
  1592.  
  1593. /* forward declarations */
  1594. FORWARD NODE *stacktop();
  1595.  
  1596. /* xlfail - xlisp error handler */
  1597. /*VARARGS*/
  1598. xlfail(emsg)
  1599.   char *emsg;
  1600. {
  1601.     xlerror(emsg,stacktop());
  1602. }
  1603.  
  1604. /* xlabort - xlisp serious error handler */
  1605. xlabort(emsg)
  1606.   char *emsg;
  1607. {
  1608.     xlsignal(emsg,s_unbound);
  1609. }
  1610.  
  1611. /* xlbreak - enter a break loop */
  1612. xlbreak(emsg,arg)
  1613.   char *emsg; NODE *arg;
  1614. {
  1615.     breakloop("break",NULL,emsg,arg,TRUE);
  1616. }
  1617.  
  1618. /* xlerror - handle a fatal error */
  1619. xlerror(emsg,arg)
  1620.   char *emsg; NODE *arg;
  1621. {
  1622.     doerror(NULL,emsg,arg,FALSE);
  1623. }
  1624.  
  1625. /* xlcerror - handle a recoverable error */
  1626. xlcerror(cmsg,emsg,arg)
  1627.   char *cmsg,*emsg; NODE *arg;
  1628. {
  1629.     doerror(cmsg,emsg,arg,TRUE);
  1630. }
  1631.  
  1632. /* xlerrprint - print an error message */
  1633. xlerrprint(hdr,cmsg,emsg,arg)
  1634.   char *hdr,*cmsg,*emsg; NODE *arg;
  1635. {
  1636.     sprintf(buf,"%s: %s",hdr,emsg); stdputstr(buf);
  1637.     if (arg != s_unbound) { stdputstr(" - "); stdprint(arg); }
  1638.     else xlterpri(getvalue(s_stdout));
  1639.     if (cmsg) { sprintf(buf,"if continued: %s\n",cmsg); stdputstr(buf); }
  1640. }
  1641.  
  1642. /* doerror - handle xlisp errors */
  1643. LOCAL doerror(cmsg,emsg,arg,cflag)
  1644.   char *cmsg,*emsg; NODE *arg; int cflag;
  1645. {
  1646.     /* make sure the break loop is enabled */
  1647.     if (getvalue(s_breakenable) == NIL)
  1648.     xlsignal(emsg,arg);
  1649.  
  1650.     /* call the debug read-eval-print loop */
  1651.     breakloop("error",cmsg,emsg,arg,cflag);
  1652. }
  1653.  
  1654. /* breakloop - the debug read-eval-print loop */
  1655. LOCAL int breakloop(hdr,cmsg,emsg,arg,cflag)
  1656.   char *hdr,*cmsg,*emsg; NODE *arg; int cflag;
  1657. {
  1658.     NODE ***oldstk,*expr,*val;
  1659.     CONTEXT cntxt;
  1660.     int type;
  1661.  
  1662.     /* print the error message */
  1663.     xlerrprint(hdr,cmsg,emsg,arg);
  1664.  
  1665.     /* flush the input buffer */
  1666.     xlflush();
  1667.  
  1668.     /* do the back trace */
  1669.     if (getvalue(s_tracenable)) {
  1670.     val = getvalue(s_tlimit);
  1671.     xlbaktrace(fixp(val) ? (int)getfixnum(val) : -1);
  1672.     }
  1673.  
  1674.     /* create a new stack frame */
  1675.     oldstk = xlsave(&expr,(NODE **)NULL);
  1676.  
  1677.     /* increment the debug level */
  1678.     xldebug++;
  1679.  
  1680.     /* debug command processing loop */
  1681.     xlbegin(&cntxt,CF_ERROR|CF_CLEANUP|CF_CONTINUE,true);
  1682.     for (type = 0; type == 0; ) {
  1683.  
  1684.     /* setup the continue trap */
  1685.     if (type = setjmp(cntxt.c_jmpbuf))
  1686.         switch (type) {
  1687.         case CF_ERROR:
  1688.             xlflush();
  1689.             type = 0;
  1690.             continue;
  1691.         case CF_CLEANUP:
  1692.             continue;
  1693.         case CF_CONTINUE:
  1694.             if (cflag) {
  1695.             stdputstr("[ continue from break loop ]\n");
  1696.             continue;
  1697.             }
  1698.             else xlabort("this error can't be continued");
  1699.         }
  1700.  
  1701.     /* read an expression and check for eof */
  1702.     if (!xlread(getvalue(s_stdin),&expr,FALSE)) {
  1703.         type = CF_CLEANUP;
  1704.         break;
  1705.     }
  1706.  
  1707.     /* evaluate the expression */
  1708.     expr = xleval(expr);
  1709.  
  1710.     /* print it */
  1711.     xlprint(getvalue(s_stdout),expr,TRUE);
  1712.     xlterpri(getvalue(s_stdout));
  1713.     }
  1714.     xlend(&cntxt);
  1715.  
  1716.     /* decrement the debug level */
  1717.     xldebug--;
  1718.  
  1719.     /* restore the previous stack frame */
  1720.     xlstack = oldstk;
  1721.  
  1722.     /* check for aborting to the previous level */
  1723.     if (type == CF_CLEANUP) {
  1724.     stdputstr("[ abort to previous level ]\n");
  1725.     xlsignal(NULL,NIL);
  1726.     }
  1727. }
  1728.  
  1729. /* stacktop - return the top node on the stack */
  1730. LOCAL NODE *stacktop()
  1731. {
  1732.     return (xltrace >= 0 && xltrace < TDEPTH ? trace_stack[xltrace] : s_unbound);
  1733. }
  1734.  
  1735. /* baktrace - do a back trace */
  1736. xlbaktrace(n)
  1737.   int n;
  1738. {
  1739.     int i;
  1740.  
  1741.     for (i = xltrace; (n < 0 || n--) && i >= 0; i--)
  1742.     if (i < TDEPTH)
  1743.         stdprint(trace_stack[i]);
  1744. }
  1745.  
  1746. /* xldinit - debug initialization routine */
  1747. xldinit()
  1748. {
  1749.     if ((trace_stack = (NODE **)malloc(TDEPTH * sizeof(NODE *))) == NULL) {
  1750.     printf("insufficient memory");
  1751.     osfinish();
  1752.     exit(1);
  1753.     }
  1754.     total += (long)(TDEPTH * sizeof(NODE *));
  1755.     xlsample = 0;
  1756.     xltrace = -1;
  1757.     xldebug = 0;
  1758. }
  1759.  
  1760.  
  1761. SHAR_EOF
  1762. fi # end of overwriting check
  1763. if test -f 'xldmem.c'
  1764. then
  1765.     echo shar: will not over-write existing file "'xldmem.c'"
  1766. else
  1767. cat << \SHAR_EOF > 'xldmem.c'
  1768. /* xldmem - xlisp dynamic memory management routines */
  1769. /*    Copyright (c) 1985, by David Michael Betz
  1770.     All Rights Reserved
  1771.     Permission is granted for unrestricted non-commercial use    */
  1772.  
  1773. #include "xlisp.h"
  1774.  
  1775. /* useful definitions */
  1776. #define ALLOCSIZE (sizeof(struct segment) + (anodes-1) * sizeof(NODE))
  1777.  
  1778. /* external variables */
  1779. extern NODE ***xlstack,***xlstkbase,***xlstktop;
  1780. extern NODE *obarray;
  1781. extern NODE *xlenv;
  1782. extern long total;
  1783. extern int anodes,nnodes,nsegs,nfree,gccalls;
  1784. extern struct segment *segs;
  1785. extern NODE *fnodes;
  1786. extern char buf[];
  1787.  
  1788. /* external procedures */
  1789. extern char *malloc();
  1790. extern char *calloc();
  1791.  
  1792. /* forward declarations */
  1793. FORWARD NODE *newnode();
  1794. FORWARD char *strsave();
  1795. FORWARD char *stralloc();
  1796.  
  1797. /* cons - construct a new cons node */
  1798. NODE *cons(x,y)
  1799.   NODE *x,*y;
  1800. {
  1801.     NODE *val;
  1802.     val = newnode(LIST);
  1803.     rplaca(val,x);
  1804.     rplacd(val,y);
  1805.     return (val);
  1806. }
  1807.  
  1808. /* consa - (cons x nil) */
  1809. NODE *consa(x)
  1810.   NODE *x;
  1811. {
  1812.     NODE *val;
  1813.     val = newnode(LIST);
  1814.     rplaca(val,x);
  1815.     return (val);
  1816. }
  1817.  
  1818. /* consd - (cons nil x) */
  1819. NODE *consd(x)
  1820.   NODE *x;
  1821. {
  1822.     NODE *val;
  1823.     val = newnode(LIST);
  1824.     rplacd(val,x);
  1825.     return (val);
  1826. }
  1827.  
  1828. /* cvstring - convert a string to a string node */
  1829. NODE *cvstring(str)
  1830.   char *str;
  1831. {
  1832.     NODE ***oldstk,*val;
  1833.     oldstk = xlsave(&val,(NODE **)NULL);
  1834.     val = newnode(STR);
  1835.     val->n_str = strsave(str);
  1836.     val->n_strtype = DYNAMIC;
  1837.     xlstack = oldstk;
  1838.     return (val);
  1839. }
  1840.  
  1841. /* cvcstring - convert a constant string to a string node */
  1842. NODE *cvcstring(str)
  1843.   char *str;
  1844. {
  1845.     NODE *val;
  1846.     val = newnode(STR);
  1847.     val->n_str = str;
  1848.     val->n_strtype = STATIC;
  1849.     return (val);
  1850. }
  1851.  
  1852. /* cvsymbol - convert a string to a symbol */
  1853. NODE *cvsymbol(pname)
  1854.   char *pname;
  1855. {
  1856.     NODE ***oldstk,*val;
  1857.     oldstk = xlsave(&val,(NODE **)NULL);
  1858.     val = newnode(SYM);
  1859.     val->n_symplist = newnode(LIST);
  1860.     rplaca(val->n_symplist,cvstring(pname));
  1861.     xlstack = oldstk;
  1862.     return (val);
  1863. }
  1864.  
  1865. /* cvcsymbol - convert a constant string to a symbol */
  1866. NODE *cvcsymbol(pname)
  1867.   char *pname;
  1868. {
  1869.     NODE ***oldstk,*val;
  1870.     oldstk = xlsave(&val,(NODE **)NULL);
  1871.     val = newnode(SYM);
  1872.     val->n_symplist = newnode(LIST);
  1873.     rplaca(val->n_symplist,cvcstring(pname));
  1874.     xlstack = oldstk;
  1875.     return (val);
  1876. }
  1877.  
  1878. /* cvsubr - convert a function to a subr or fsubr */
  1879. NODE *cvsubr(fcn,type)
  1880.   NODE *(*fcn)(); int type;
  1881. {
  1882.     NODE *val;
  1883.     val = newnode(type);
  1884.     val->n_subr = fcn;
  1885.     return (val);
  1886. }
  1887.  
  1888. /* cvfile - convert a file pointer to a file */
  1889. NODE *cvfile(fp)
  1890.   FILE *fp;
  1891. {
  1892.     NODE *val;
  1893.     val = newnode(FPTR);
  1894.     setfile(val,fp);
  1895.     setsavech(val,0);
  1896.     return (val);
  1897. }
  1898.  
  1899. /* cvfixnum - convert an integer to a fixnum node */
  1900. NODE *cvfixnum(n)
  1901.   FIXNUM n;
  1902. {
  1903.     NODE *val;
  1904.     val = newnode(INT);
  1905.     val->n_int = n;
  1906.     return (val);
  1907. }
  1908.  
  1909. /* cvflonum - convert a floating point number to a flonum node */
  1910. NODE *cvflonum(n)
  1911.   FLONUM n;
  1912. {
  1913.     NODE *val;
  1914.     val = newnode(FLOAT);
  1915.     val->n_float = n;
  1916.     return (val);
  1917. }
  1918.  
  1919. /* newstring - allocate and initialize a new string */
  1920. NODE *newstring(size)
  1921.   int size;
  1922. {
  1923.     NODE ***oldstk,*val;
  1924.     oldstk = xlsave(&val,(NODE **)NULL);
  1925.     val = newnode(STR);
  1926.     val->n_str = stralloc(size);
  1927.     *getstring(val) = 0;
  1928.     val->n_strtype = DYNAMIC;
  1929.     xlstack = oldstk;
  1930.     return (val);
  1931. }
  1932.  
  1933. /* newobject - allocate and initialize a new object */
  1934. NODE *newobject(cls,size)
  1935.   NODE *cls; int size;
  1936. {
  1937.     NODE *val;
  1938.     val = newvector(size+1);
  1939.     setelement(val,0,cls);
  1940.     val->n_type = OBJ;
  1941.     return (val);
  1942. }
  1943.  
  1944. /* newvector - allocate and initialize a new vector node */
  1945. NODE *newvector(size)
  1946.   int size;
  1947. {
  1948.     NODE ***oldstk,*vect;
  1949.     int bsize;
  1950.  
  1951.     /* establish a new stack frame */
  1952.     oldstk = xlsave(&vect,(NODE **)NULL);
  1953.  
  1954.     /* allocate a vector node and set the size to zero (in case of gc) */
  1955.     vect = newnode(VECT);
  1956.     vect->n_vsize = 0;
  1957.  
  1958.     /* allocate memory for the vector */
  1959.     bsize = size * sizeof(NODE *);
  1960.     if ((vect->n_vdata = (NODE **) calloc(1,bsize)) == NULL) {
  1961.     findmem();
  1962.     if ((vect->n_vdata = (NODE **) calloc(1,bsize)) == NULL)
  1963.         xlfail("insufficient vector space");
  1964.     }
  1965.     vect->n_vsize = size;
  1966.     total += (long) bsize;
  1967.  
  1968.     /* restore the previous stack frame */
  1969.     xlstack = oldstk;
  1970.  
  1971.     /* return the new vector */
  1972.     return (vect);
  1973. }
  1974.  
  1975. /* newnode - allocate a new node */
  1976. LOCAL NODE *newnode(type)
  1977.   int type;
  1978. {
  1979.     NODE *nnode;
  1980.  
  1981.     /* get a free node */
  1982.     if ((nnode = fnodes) == NIL) {
  1983.     findmem();
  1984.     if ((nnode = fnodes) == NIL)
  1985.         xlabort("insufficient node space");
  1986.     }
  1987.  
  1988.     /* unlink the node from the free list */
  1989.     fnodes = cdr(nnode);
  1990.     nfree -= 1;
  1991.  
  1992.     /* initialize the new node */
  1993.     nnode->n_type = type;
  1994.     rplacd(nnode,NIL);
  1995.  
  1996.     /* return the new node */
  1997.     return (nnode);
  1998. }
  1999.  
  2000. /* stralloc - allocate memory for a string adding a byte for the terminator */
  2001. LOCAL char *stralloc(size)
  2002.   int size;
  2003. {
  2004.     char *sptr;
  2005.  
  2006.     /* allocate memory for the string copy */
  2007.     if ((sptr = malloc(size+1)) == NULL) {
  2008.     findmem();  
  2009.     if ((sptr = malloc(size+1)) == NULL)
  2010.         xlfail("insufficient string space");
  2011.     }
  2012.     total += (long) (size+1);
  2013.  
  2014.     /* return the new string memory */
  2015.     return (sptr);
  2016. }
  2017.  
  2018. /* strsave - generate a dynamic copy of a string */
  2019. LOCAL char *strsave(str)
  2020.   char *str;
  2021. {
  2022.     char *sptr;
  2023.  
  2024.     /* create a new string */
  2025.     sptr = stralloc(strlen(str));
  2026.     strcpy(sptr,str);
  2027.  
  2028.     /* return the new string */
  2029.     return (sptr);
  2030. }
  2031.  
  2032. /* strfree - free a string                 UNUSED
  2033. LOCAL strfree(str)
  2034.   char *str;
  2035. {
  2036.     total -= (long) (strlen(str)+1);
  2037.     free(str);
  2038. }
  2039. */
  2040.  
  2041. /* findmem - find more memory by collecting then expanding */
  2042. findmem()
  2043. {
  2044.     gc();
  2045.     if (nfree < anodes)
  2046.     addseg();
  2047. }
  2048.  
  2049. /* gc - garbage collect */
  2050. gc()
  2051. {
  2052.     NODE ***p;
  2053.     void mark();
  2054.  
  2055.     /* mark the obarray and the current environment */
  2056.     mark(obarray);
  2057.     mark(xlenv);
  2058.  
  2059.     /* mark the evaluation stack */
  2060.     for (p = xlstack; p < xlstktop; )
  2061.     mark(**p++);
  2062.  
  2063.     /* sweep memory collecting all unmarked nodes */
  2064.     sweep();
  2065.  
  2066.     /* count the gc call */
  2067.     gccalls++;
  2068. }
  2069.  
  2070. /* mark - mark all accessible nodes */
  2071. void mark(ptr)
  2072.   NODE *ptr;
  2073. {
  2074.     NODE *this,*prev,*tmp;
  2075.  
  2076.     /* just return on nil */
  2077.     if (ptr == NIL)
  2078.     return;
  2079.  
  2080.     /* initialize */
  2081.     prev = NIL;
  2082.     this = ptr;
  2083.  
  2084.     /* mark this list */
  2085.     while (TRUE) {
  2086.  
  2087.     /* descend as far as we can */
  2088.     while (TRUE) {
  2089.  
  2090.         /* check for this node being marked */
  2091.         if (this->n_flags & MARK)
  2092.         break;
  2093.  
  2094.         /* mark it and its descendants */
  2095.         else {
  2096.  
  2097.         /* mark the node */
  2098.         this->n_flags |= MARK;
  2099.  
  2100.         /* follow the left sublist if there is one */
  2101.         if (livecar(this)) {
  2102.             this->n_flags |= LEFT;
  2103.             tmp = prev;
  2104.             prev = this;
  2105.             this = car(prev);
  2106.             rplaca(prev,tmp);
  2107.         }
  2108.  
  2109.         /* otherwise, follow the right sublist if there is one */
  2110.         else if (livecdr(this)) {
  2111.             this->n_flags &= ~LEFT;
  2112.             tmp = prev;
  2113.             prev = this;
  2114.             this = cdr(prev);
  2115.             rplacd(prev,tmp);
  2116.         }
  2117.         else
  2118.             break;
  2119.         }
  2120.     }
  2121.  
  2122.     /* backup to a point where we can continue descending */
  2123.     while (TRUE) {
  2124.  
  2125.         /* check for termination condition */
  2126.         if (prev == NIL)
  2127.         return;
  2128.  
  2129.         /* check for coming from the left side */
  2130.         if (prev->n_flags & LEFT)
  2131.         if (livecdr(prev)) {
  2132.             prev->n_flags &= ~LEFT;
  2133.             tmp = car(prev);
  2134.             rplaca(prev,this);
  2135.             this = cdr(prev);
  2136.             rplacd(prev,tmp);
  2137.             break;
  2138.         }
  2139.         else {
  2140.             tmp = prev;
  2141.             prev = car(tmp);
  2142.             rplaca(tmp,this);
  2143.             this = tmp;
  2144.         }
  2145.  
  2146.         /* otherwise, came from the right side */
  2147.         else {
  2148.         tmp = prev;
  2149.         prev = cdr(tmp);
  2150.         rplacd(tmp,this);
  2151.         this = tmp;
  2152.         }
  2153.     }
  2154.     }
  2155. }
  2156.  
  2157. /* vmark - mark a vector */
  2158. vmark(n)
  2159.   NODE *n;
  2160. {
  2161.     int i;
  2162.     for (i = 0; i < getsize(n); ++i)
  2163.     mark(getelement(n,i));
  2164. }
  2165.  
  2166. /* sweep - sweep all unmarked nodes and add them to the free list */
  2167. LOCAL sweep()
  2168. {
  2169.     struct segment *seg;
  2170.     NODE *p;
  2171.     int n;
  2172.  
  2173.     /* empty the free list */
  2174.     fnodes = NIL;
  2175.     nfree = 0;
  2176.  
  2177.     /* add all unmarked nodes */
  2178.     for (seg = segs; seg != NULL; seg = seg->sg_next) {
  2179.     p = &seg->sg_nodes[0];
  2180.     for (n = seg->sg_size; n--; p++)
  2181.         if (!(p->n_flags & MARK)) {
  2182.         switch (ntype(p)) {
  2183.         case STR:
  2184.             if (p->n_strtype == DYNAMIC && p->n_str != NULL) {
  2185.                 total -= (long) (strlen(p->n_str)+1);
  2186.                 free(p->n_str);
  2187.             }
  2188.             break;
  2189.         case FPTR:
  2190.             if (p->n_fp)
  2191.                 fclose(p->n_fp);
  2192.             break;
  2193.         case VECT:
  2194.             if (p->n_vsize) {
  2195.                 total -= (long) (p->n_vsize * sizeof(NODE **));
  2196.                 free(p->n_vdata);
  2197.             }
  2198.             break;
  2199.         }
  2200.         p->n_type = FREE;
  2201.         p->n_flags = 0;
  2202.         rplaca(p,NIL);
  2203.         rplacd(p,fnodes);
  2204.         fnodes = p;
  2205.         nfree++;
  2206.         }
  2207.         else
  2208.         p->n_flags &= ~(MARK | LEFT);
  2209.     }
  2210. }
  2211.  
  2212. /* addseg - add a segment to the available memory */
  2213. int addseg()
  2214. {
  2215.     struct segment *newseg;
  2216.     NODE *p;
  2217.     int n;
  2218.  
  2219.     /* check for zero allocation */
  2220.     if (anodes == 0)
  2221.     return (FALSE);
  2222.  
  2223.     /* allocate a new segment */
  2224.     if ((newseg = (struct segment *) calloc(1,ALLOCSIZE)) != NULL) {
  2225.  
  2226.     /* initialize the new segment */
  2227.     newseg->sg_size = anodes;
  2228.     newseg->sg_next = segs;
  2229.     segs = newseg;
  2230.  
  2231.     /* add each new node to the free list */
  2232.     p = &newseg->sg_nodes[0];
  2233.     for (n = anodes; n--; ) {
  2234.         rplacd(p,fnodes);
  2235.         fnodes = p++;
  2236.     }
  2237.  
  2238.     /* update the statistics */
  2239.     total += (long) ALLOCSIZE;
  2240.     nnodes += anodes;
  2241.     nfree += anodes;
  2242.     nsegs++;
  2243.  
  2244.     /* return successfully */
  2245.     return (TRUE);
  2246.     }
  2247.     else
  2248.     return (FALSE);
  2249. }
  2250.  
  2251. /* livecar - do we need to follow the car? */
  2252. LOCAL int livecar(n)
  2253.   NODE *n;
  2254. {
  2255.     switch (ntype(n)) {
  2256.     case OBJ:
  2257.     case VECT:
  2258.         vmark(n);
  2259.     case SUBR:
  2260.     case FSUBR:
  2261.     case INT:
  2262.     case FLOAT:
  2263.     case STR:
  2264.     case FPTR:
  2265.         return (FALSE);
  2266.     case SYM:
  2267.     case LIST:
  2268.         return (car(n) != NIL);
  2269.     default:
  2270.         printf("bad node type (%d) found during left scan\n",ntype(n));
  2271.         osfinish ();
  2272.         exit(1);
  2273.     }
  2274.     /*NOTREACHED*/
  2275. }
  2276.  
  2277. /* livecdr - do we need to follow the cdr? */
  2278. LOCAL int livecdr(n)
  2279.   NODE *n;
  2280. {
  2281.     switch (ntype(n)) {
  2282.     case SUBR:
  2283.     case FSUBR:
  2284.     case INT:
  2285.     case FLOAT:
  2286.     case STR:
  2287.     case FPTR:
  2288.     case OBJ:
  2289.     case VECT:
  2290.         return (FALSE);
  2291.     case SYM:
  2292.     case LIST:
  2293.         return (cdr(n) != NIL);
  2294.     default:
  2295.         printf("bad node type (%d) found during right scan\n",ntype(n));
  2296.         osfinish ();
  2297.         exit(1);
  2298.     }
  2299.     /*NOTREACHED*/
  2300. }
  2301.  
  2302. /* stats - print memory statistics */
  2303. stats()
  2304. {
  2305.     sprintf(buf,"Nodes:       %d\n",nnodes);  stdputstr(buf);
  2306.     sprintf(buf,"Free nodes:  %d\n",nfree);   stdputstr(buf);
  2307.     sprintf(buf,"Segments:    %d\n",nsegs);   stdputstr(buf);
  2308.     sprintf(buf,"Allocate:    %d\n",anodes);  stdputstr(buf);
  2309.     sprintf(buf,"Total:       %ld\n",total);  stdputstr(buf);
  2310.     sprintf(buf,"Collections: %d\n",gccalls); stdputstr(buf);
  2311. }
  2312.  
  2313. /* xlminit - initialize the dynamic memory module */
  2314. xlminit()
  2315. {
  2316.     /* initialize our internal variables */
  2317.     anodes = NNODES;
  2318.     total = 0L;
  2319.     nnodes = nsegs = nfree = gccalls = 0;
  2320.     fnodes = NIL;
  2321.     segs = NULL;
  2322.  
  2323.     /* initialize structures that are marked by the collector */
  2324.     xlenv = obarray = NIL;
  2325.  
  2326.     /* allocate the evaluation stack */
  2327.     if ((xlstkbase = (NODE ***)malloc(EDEPTH * sizeof(NODE **))) == NULL) {
  2328.     printf("insufficient memory");
  2329.     osfinish ();
  2330.     exit(1);
  2331.     }
  2332.     total += (long)(EDEPTH * sizeof(NODE **));
  2333.     xlstack = xlstktop = xlstkbase + EDEPTH;
  2334. }
  2335.  
  2336. SHAR_EOF
  2337. fi # end of overwriting check
  2338. if test -f 'xleval.c'
  2339. then
  2340.     echo shar: will not over-write existing file "'xleval.c'"
  2341. else
  2342. cat << \SHAR_EOF > 'xleval.c'
  2343. /* xleval - xlisp evaluator */
  2344. /*    Copyright (c) 1985, by David Michael Betz
  2345.     All Rights Reserved
  2346.     Permission is granted for unrestricted non-commercial use    */
  2347.  
  2348. #include "xlisp.h"
  2349.  
  2350. /* external variables */
  2351. extern int xlsample;
  2352. extern NODE ***xlstack,***xlstkbase,*xlenv;
  2353. extern NODE *s_lambda,*s_macro;
  2354. extern NODE *k_optional,*k_rest,*k_aux;
  2355. extern NODE *s_evalhook,*s_applyhook;
  2356. extern NODE *s_unbound;
  2357. extern NODE *s_stdout;
  2358.  
  2359. /* trace variables */
  2360. extern NODE **trace_stack;
  2361. extern int xltrace;
  2362.  
  2363. /* forward declarations */
  2364. FORWARD NODE *xlxeval();
  2365. FORWARD NODE *evalhook();
  2366. FORWARD NODE *evform();
  2367. FORWARD NODE *evfun();
  2368.  
  2369. /* xleval - evaluate an xlisp expression (checking for *evalhook*) */
  2370. NODE *xleval(expr)
  2371.   NODE *expr;
  2372. {
  2373.     /* check for control codes */
  2374.     if (--xlsample <= 0) {
  2375.     xlsample = SAMPLE;
  2376.     oscheck();
  2377.     }
  2378.  
  2379.     /* check for *evalhook* */
  2380.     if (getvalue(s_evalhook))
  2381.     return (evalhook(expr));
  2382.  
  2383.     /* add trace entry */
  2384.     if (++xltrace < TDEPTH)
  2385.     trace_stack[xltrace] = expr;
  2386.  
  2387.     /* check type of value */
  2388.     if (consp(expr))
  2389.     expr = evform(expr);
  2390.     else if (symbolp(expr))
  2391.     expr = xlgetvalue(expr);
  2392.  
  2393.     /* remove trace entry */
  2394.     --xltrace;
  2395.  
  2396.     /* return the value */
  2397.     return (expr);
  2398. }
  2399.  
  2400. /* xlxeval - evaluate an xlisp expression (bypassing *evalhook*) */
  2401. NODE *xlxeval(expr)
  2402.   NODE *expr;
  2403. {
  2404.     /* check type of value */
  2405.     if (consp(expr))
  2406.     expr = evform(expr);
  2407.     else if (symbolp(expr))
  2408.     expr = xlgetvalue(expr);
  2409.  
  2410.     /* return the value */
  2411.     return (expr);
  2412. }
  2413.  
  2414. /* xlapply - apply a function to a list of arguments */
  2415. NODE *xlapply(fun,args)
  2416.   NODE *fun,*args;
  2417. {
  2418.     NODE *env,*val;
  2419.  
  2420.     /* check for a null function */
  2421.     if (fun == NIL)
  2422.     xlfail("bad function");
  2423.  
  2424.     /* evaluate the function */
  2425.     if (subrp(fun))
  2426.     val = (*getsubr(fun))(args);
  2427.     else if (consp(fun)) {
  2428.     if (consp(car(fun))) {
  2429.         env = cdr(fun);
  2430.         fun = car(fun);
  2431.     }
  2432.     else
  2433.         env = xlenv;
  2434.     if (car(fun) != s_lambda)
  2435.         xlfail("bad function type");
  2436.     val = evfun(fun,args,env);
  2437.     }
  2438.     else
  2439.     xlfail("bad function");
  2440.  
  2441.     /* return the result value */
  2442.     return (val);
  2443. }
  2444.  
  2445. /* evform - evaluate a form */
  2446. LOCAL NODE *evform(expr)
  2447.   NODE *expr;
  2448. {
  2449.     NODE ***oldstk,*fun,*args,*env,*val,*type;
  2450.  
  2451.     /* create a stack frame */
  2452.     oldstk = xlsave(&fun,&args,(NODE **)NULL);
  2453.  
  2454.     /* get the function and the argument list */
  2455.     fun = car(expr);
  2456.     args = cdr(expr);
  2457.  
  2458.     /* evaluate the first expression */
  2459.     if ((fun = xleval(fun)) == NIL)
  2460.     xlfail("bad function");
  2461.  
  2462.     /* evaluate the function */
  2463.     if (subrp(fun) || fsubrp(fun)) {
  2464.     if (subrp(fun))
  2465.         args = xlevlist(args);
  2466.     val = (*getsubr(fun))(args);
  2467.     }
  2468.     else if (consp(fun)) {
  2469.     if (consp(car(fun))) {
  2470.         env = cdr(fun);
  2471.         fun = car(fun);
  2472.     }
  2473.     else
  2474.         env = xlenv;
  2475.     if ((type = car(fun)) == s_lambda) {
  2476.         args = xlevlist(args);
  2477.         val = evfun(fun,args,env);
  2478.     }
  2479.     else if (type == s_macro) {
  2480.         args = evfun(fun,args,env);
  2481.         val = xleval(args);
  2482.     }
  2483.     else
  2484.         xlfail("bad function type");
  2485.     }
  2486.     else if (objectp(fun))
  2487.     val = xlsend(fun,args);
  2488.     else
  2489.     xlfail("bad function");
  2490.  
  2491.     /* restore the previous stack frame */
  2492.     xlstack = oldstk;
  2493.  
  2494.     /* return the result value */
  2495.     return (val);
  2496. }
  2497.  
  2498. /* evalhook - call the evalhook function */
  2499. LOCAL NODE *evalhook(expr)
  2500.   NODE *expr;
  2501. {
  2502.     NODE ***oldstk,*ehook,*ahook,*args,*val;
  2503.  
  2504.     /* create a new stack frame */
  2505.     oldstk = xlsave(&ehook,&ahook,&args,(NODE **)NULL);
  2506.  
  2507.     /* make an argument list */
  2508.     args = consa(expr);
  2509.     rplacd(args,consa(xlenv));
  2510.  
  2511.     /* rebind the hook functions to nil */
  2512.     ehook = getvalue(s_evalhook);
  2513.     setvalue(s_evalhook,NIL);
  2514.     ahook = getvalue(s_applyhook);
  2515.     setvalue(s_applyhook,NIL);
  2516.  
  2517.     /* call the hook function */
  2518.     val = xlapply(ehook,args);
  2519.  
  2520.     /* unbind the symbols */
  2521.     setvalue(s_evalhook,ehook);
  2522.     setvalue(s_applyhook,ahook);
  2523.  
  2524.     /* restore the previous stack frame */
  2525.     xlstack = oldstk;
  2526.  
  2527.     /* return the value */
  2528.     return (val);
  2529. }
  2530.  
  2531. /* xlevlist - evaluate a list of arguments */
  2532. NODE *xlevlist(args)
  2533.   NODE *args;
  2534. {
  2535.     NODE ***oldstk,*src,*dst,*new,*val;
  2536.     NODE *last = NIL;
  2537.  
  2538.     /* create a stack frame */
  2539.     oldstk = xlsave(&src,&dst,(NODE **)NULL);
  2540.  
  2541.     /* initialize */
  2542.     src = args;
  2543.  
  2544.     /* evaluate each argument */
  2545.     for (val = NIL; src; src = cdr(src)) {
  2546.  
  2547.     /* check this entry */
  2548.     if (!consp(src))
  2549.         xlfail("bad argument list");
  2550.  
  2551.     /* allocate a new list entry */
  2552.     new = consa(NIL);
  2553.     if (val)
  2554.         rplacd(last,new);
  2555.     else
  2556.         val = dst = new;
  2557.     rplaca(new,xleval(car(src)));
  2558.     last = new;
  2559.     }
  2560.  
  2561.     /* restore the previous stack frame */
  2562.     xlstack = oldstk;
  2563.  
  2564.     /* return the new list */
  2565.     return (val);
  2566. }
  2567.  
  2568. /* xlunbound - signal an unbound variable error */
  2569. xlunbound(sym)
  2570.   NODE *sym;
  2571. {
  2572.     xlcerror("try evaluating symbol again","unbound variable",sym);
  2573. }
  2574.  
  2575. /* evfun - evaluate a function */
  2576. LOCAL NODE *evfun(fun,args,env)
  2577.   NODE *fun,*args,*env;
  2578. {
  2579.     NODE ***oldstk,*oldenv,*newenv,*cptr,*fargs,*val;
  2580.  
  2581.     /* create a stack frame */
  2582.     oldstk = xlsave(&oldenv,&newenv,&cptr,(NODE **)NULL);
  2583.  
  2584.     /* skip the function type */
  2585.     if ((fun = cdr(fun)) == NIL || !consp(fun))
  2586.     xlfail("bad function definition");
  2587.  
  2588.     /* get the formal argument list */
  2589.     if ((fargs = car(fun)) && !consp(fargs))
  2590.     xlfail("bad formal argument list");
  2591.  
  2592.     /* create a new environment frame */
  2593.     newenv = xlframe(env);
  2594.     oldenv = xlenv;
  2595.  
  2596.     /* bind the formal parameters */
  2597.     xlabind(fargs,args,newenv);
  2598.     xlenv = newenv;
  2599.  
  2600.     /* execute the code */
  2601.     for (cptr = cdr(fun); cptr; )
  2602.     val = xlevarg(&cptr);
  2603.  
  2604.     /* restore the environment */
  2605.     xlenv = oldenv;
  2606.  
  2607.     /* restore the previous stack frame */
  2608.     xlstack = oldstk;
  2609.  
  2610.     /* return the result value */
  2611.     return (val);
  2612. }
  2613.  
  2614. /* xlabind - bind the arguments for a function */
  2615. xlabind(fargs,aargs,env)
  2616.   NODE *fargs,*aargs,*env;
  2617. {
  2618.     NODE *arg;
  2619.  
  2620.     /* evaluate and bind each required argument */
  2621.     while (consp(fargs) && !iskeyword(arg = car(fargs)) && consp(aargs)) {
  2622.  
  2623.     /* bind the formal variable to the argument value */
  2624.     xlbind(arg,car(aargs),env);
  2625.  
  2626.     /* move the argument list pointers ahead */
  2627.     fargs = cdr(fargs);
  2628.     aargs = cdr(aargs);
  2629.     }
  2630.  
  2631.     /* check for the '&optional' keyword */
  2632.     if (consp(fargs) && car(fargs) == k_optional) {
  2633.     fargs = cdr(fargs);
  2634.  
  2635.     /* bind the arguments that were supplied */
  2636.     while (consp(fargs) && !iskeyword(arg = car(fargs)) && consp(aargs)) {
  2637.  
  2638.         /* bind the formal variable to the argument value */
  2639.         xlbind(arg,car(aargs),env);
  2640.  
  2641.         /* move the argument list pointers ahead */
  2642.         fargs = cdr(fargs);
  2643.         aargs = cdr(aargs);
  2644.     }
  2645.  
  2646.     /* bind the rest to nil */
  2647.     while (consp(fargs) && !iskeyword(arg = car(fargs))) {
  2648.  
  2649.         /* bind the formal variable to nil */
  2650.         xlbind(arg,NIL,env);
  2651.  
  2652.         /* move the argument list pointer ahead */
  2653.         fargs = cdr(fargs);
  2654.     }
  2655.     }
  2656.  
  2657.     /* check for the '&rest' keyword */
  2658.     if (consp(fargs) && car(fargs) == k_rest) {
  2659.     fargs = cdr(fargs);
  2660.     if (consp(fargs) && (arg = car(fargs)) && !iskeyword(arg))
  2661.         xlbind(arg,aargs,env);
  2662.     else
  2663.         xlfail("symbol missing after &rest");
  2664.     fargs = cdr(fargs);
  2665.     aargs = NIL;
  2666.     }
  2667.  
  2668.     /* check for the '&aux' keyword */
  2669.     if (consp(fargs) && car(fargs) == k_aux)
  2670.     while ((fargs = cdr(fargs)) != NIL && consp(fargs))
  2671.         xlbind(car(fargs),NIL,env);
  2672.  
  2673.     /* make sure the correct number of arguments were supplied */
  2674.     if (fargs != aargs)
  2675.     xlfail(fargs ? "too few arguments" : "too many arguments");
  2676. }
  2677.  
  2678. /* iskeyword - check to see if a symbol is a keyword */
  2679. LOCAL int iskeyword(sym)
  2680.   NODE *sym;
  2681. {
  2682.     return (sym == k_optional || sym == k_rest || sym == k_aux);
  2683. }
  2684.  
  2685. /* xlsave - save nodes on the stack */
  2686. /*VARARGS*/
  2687. NODE ***xlsave(n)
  2688.   NODE **n;
  2689. {
  2690.     NODE ***oldstk,***nptr;
  2691.  
  2692.     /* save the old stack pointer */
  2693.     oldstk = xlstack;
  2694.  
  2695.     /* save each node pointer */
  2696.     for (nptr = &n; *nptr; nptr++) {
  2697.     if (xlstack <= xlstkbase)
  2698.         xlabort("evaluation stack overflow");
  2699.     *--xlstack = *nptr;
  2700.     **nptr = NIL;
  2701.     }
  2702.  
  2703.     /* return the old stack pointer */
  2704.     return (oldstk);
  2705. }
  2706.  
  2707. SHAR_EOF
  2708. fi # end of overwriting check
  2709. #    End of shell archive
  2710. exit 0
  2711.  
  2712.